use "helper.sml" ;

fun makeIsChar(string) =
    let val chars = explode(string)
    in
	fn ch => ormap (fn ch' => ch = ch') chars
    end;

fun makeCharInRange(charFrom, charTo) =
 fn ch : char => (charFrom <= ch) andalso (ch <= charTo);

fun stringEqual(string1, string2) =
    String.compare(string1, string2) = EQUAL;

datatype SchemeToken	= LparenToken
						| RparenToken
						| QuoteToken
						| DotToken
						| VectorToken
						| IntToken of int
						| CharToken of char
						| StringToken of string
						| SymbolToken of string
						| BoolToken of bool;

exception ErrorNothingAfterHash;
exception ErrorBadChar of char * string;
exception ErrorStringDoesntEnd of string;
exception ErrorNoMetaChar of string;
exception ErrorNoSuchMetaChar of string;
exception ErrorNoChar;
exception ErrorUnknownNamedChar of string;
exception ErrorHash of string;

signature SCANNER =
sig
    val stringToTokens : string -> SchemeToken list;
end;

(***************************************************************************************
  												 						SCANNER
***************************************************************************************)

structure Scanner : SCANNER =
struct

	val whiteChar = makeIsChar(" \t\r\n");
	val delimiterChar = makeIsChar("'()\";, \t\r\n");
	val metaChar = makeIsChar("\\tnrf\"ab");
	val octalChar = makeCharInRange(#"0", #"7");
	val upperChar = makeCharInRange(#"A", #"Z");
	val lowerChar = makeCharInRange(#"a", #"z");
	val digitChar = makeCharInRange(#"0", #"9");
	val specialSymbolChar = makeIsChar("!@$%^*-_=+<>/?.#");

	fun letterChar(ch) = (upperChar(ch) orelse lowerChar(ch)) ;
	fun alphanumeric (ch) = (letterChar(ch) orelse digitChar(ch)) ;
	fun symbolChar (ch) =
		lowerChar(ch) orelse
		upperChar(ch) orelse
		digitChar(ch) orelse
		specialSymbolChar(ch);

	local
		fun	stInit([]) = []
		|	stInit(#";" :: s) = stComment(s)
		|	stInit(#"(" :: s) = LparenToken :: stInit(s)
		|	stInit(#")" :: s) = RparenToken :: stInit(s)
		|	stInit(#"'" :: s) = QuoteToken :: stInit(s)
		|	stInit(#"#" :: s) = stHash(s)
		|	stInit(#"." :: s) = DotToken :: stInit(s)
		|	stInit(#"\"" :: s) = stString(s)
		|	stInit(#"+" :: ch :: s) =
				if digitChar(ch)
					then stPositiveNumber(ch :: s)
					else stSymbol(#"+" :: ch :: s)
		|	stInit(#"-" :: ch :: s) =
				if digitChar(ch)
					then stNegativeNumber(ch :: s)
					else stSymbol(#"-" :: ch :: s)
		|	stInit(s as ch :: s') =
				if whiteChar(ch) then stInit(s')
				else if digitChar(ch) then stPositiveNumber(s)
				else if symbolChar(ch) then stSymbol(s)
				else raise ErrorBadChar(ch, implode(s))

		and	stHash([]) = raise ErrorNothingAfterHash
		|	stHash(#"t" :: s) = BoolToken(true) :: stInit(s)
		|	stHash(#"T" :: s) = BoolToken(true) :: stInit(s)
		|	stHash(#"f" :: s) = BoolToken(false) :: stInit(s)
		|	stHash(#"F" :: s) = BoolToken(false) :: stInit(s)
		|	stHash(#"(" :: s) = VectorToken :: stInit(s)
		|	stHash(#"\\" :: s) = stChar(s)
		|	stHash(s) = raise ErrorHash("#\\" ^ implode(s))

		and	stChar([]) = raise ErrorNoChar
		|	stChar(ch :: s) = stChar'(s, [ch])

		and	stChar'([], chars) = CharToken(makeChar(chars)) :: stInit([])
		|	stChar'(ch :: s', chars) =
				if delimiterChar(ch)
					then CharToken(makeChar(chars)) :: stInit(ch :: s')
					else stChar'(s', ch :: chars)

		and	stComment([]) = stInit([])
		|	stComment(#"\n" :: s) = stInit(s)
		|	stComment(_ :: s) = stComment(s)

		and	stPositiveNumber([]) = raise ErrorNoChar
		|	stPositiveNumber(ch :: s) = stNumber'(1, digitToInt(ch), s)

		and stNegativeNumber([]) = raise ErrorNoChar
		|	stNegativeNumber(ch :: s) = stNumber'(~1, digitToInt(ch), s)

		and	stNumber'(sign, current, []) = IntToken(sign*current) :: stInit([])
		|	stNumber'(sign, current, ch :: s) =
				if digitChar(ch) then stNumber'(sign, current*10 + digitToInt(ch), s)
				else if symbolChar(ch) then stNumber'(sign, current, s)
				else IntToken(sign*current) :: stInit(ch :: s)

		and stString(s) = stString'([], s)

		and	stString'(chars, []) = raise ErrorStringDoesntEnd("")
		|	stString'(chars, #"\\" :: s) = stMetachar(chars, s)
		|	stString'(chars, #"\"" :: s) = StringToken(implode(rev(chars))) :: stInit(s)
		|	stString'(chars, ch :: s) = stString'(ch :: chars, s)

		and stMetachar(_, []) = raise ErrorNoMetaChar("")
		|	stMetachar(chars, ch :: s) =
				if metaChar(ch) then stString'(makeMetachar(ch) :: chars, s)
				else if digitChar(ch) then stMetaOctal(chars, ch :: s)
				else raise ErrorNoSuchMetaChar(implode([ch]))

		and	stMetaOctal(chars, ch1 :: ch2 :: ch3 :: s) = stString'(makeChar([ch3, ch2, ch1]) :: chars, s)
		|	stMetaOctal(_, s) = raise ErrorNoSuchMetaChar(implode(s))

		and	makeMetachar(ch) = case ch of
#"\\" => #"\\"
			|	#"t" => #"\t"
			|	#"n" => #"\n"
			|	#"r" => #"\r"
			|	#"f" => #"\f"
			|	#"a" => #"\a"
			|	#"b" => #"\b"
			|	#"\"" => #"\""
			|	_ => raise ErrorNoSuchMetaChar(implode([ch]))

		and	stSymbol([]) = stInit([])
		|	stSymbol(ch :: s) = stSymbol'([ch], s)

		and stSymbol'(chars, ch :: s) =
				if delimiterChar(ch)
					then SymbolToken(implode(rev(chars))) :: stInit(ch :: s)
					else stSymbol'(ch :: chars, s)
		|	stSymbol'(chars, []) = SymbolToken(implode(rev(chars))) :: stInit([])

		and	charsToString(s) = implode(rev(s))

		and	makeChar([ch]) = ch
		|	makeChar(chars as [ch1, ch2, ch3]) =
				if (andmap octalChar chars)
					then chr(digitToInt(ch1) + 8 * (digitToInt(ch2) + 8 * digitToInt(ch3)))
					else charNameToChar(charsToString(chars))
		|	makeChar(chars) = charNameToChar(charsToString(chars))

		and	charNameToChar(charName) =
				if stringEqual(charName, "space") then #" "
				else if stringEqual(charName, "return") then #"\r"
				else if stringEqual(charName, "newline") then #"\n"
				else if stringEqual(charName, "tab") then #"\t"
				else raise ErrorUnknownNamedChar(charName)

		and	digitToInt(ch) = ord(ch) - ord(#"0")
	in
		fun stringToTokens(string) = stInit(explode(string))
	end;
end; (* of structure Scanner *)

